home *** CD-ROM | disk | FTP | other *** search
/ HPAVC / HPAVC CD-ROM.iso / CDEMO4SR.ZIP / CDEMO4.PAS next >
Pascal/Delphi Source File  |  1994-06-01  |  14KB  |  524 lines
  1. {$G+}
  2. program CDemo4;
  3. const
  4.   NumPnts  = 156;
  5.   Xc       = 0;
  6.   Yc       = 0;
  7.   zc       = 80;
  8.   BlockMaxX = 15;    { Horiz Size Of Block }
  9.   BlockMaxY = 14;    { Vert Size Of Block }
  10.   NumSxhma = 6;
  11.   MorphSize=20;
  12.  
  13.   VSeg : word =$A000;
  14.   Sox  : Word = 160;
  15.   Soy  : Word = 100;
  16.   dist : Byte = 0;
  17.  
  18.   ScrText : string =
  19.     '        COSMOS BBS - Katerini Greece (+30-351-37382) '#1' 21:00-9:00'+
  20.     'Gmt+2 - 2400 to Zyx16.8/V32bis '#2' HQ-Greece for Pascal-Net 115:3000/0 '+
  21.     #1' Fidonet 2:410/204 '#2' SBC-Net 14:2100/201 '#1' ZyxelNet 16:800/108 '+
  22.     #2' Hellas-Net 7:2000/50 '#1' ...call us now...';
  23.   FinText : Array[1..7] of string[43] =
  24.             ('─────══════─C─O─S─M─O─S───B─B─S─══════─────',
  25.              ' Katerini, HELLAS      2:410/204 Fidonet   ',
  26.              '   +30-351-37382      115:3005/1 Pascal-Net',
  27.              ' Zyxel 16.8/V32Bis   14:2100/201 SBC-Net   ',
  28.              '                       7:2000/50 HellasNet ',
  29.              'Weekdays 21:00-09:00, Sat-Sun 24Hrs (Gmt+2)',
  30.              '         SysOp: Sokrates Passalidis        ');
  31.  
  32. Type
  33.   VGAPtr       = ^VGAType;
  34.   PaletteRec   = Record R,G,B  : Byte; End;
  35.   PaletteType  = Array[0..255] of PaletteRec;
  36.   TabType      = array[0..255] of integer;
  37.   PointArray   = Array[1..NumPnts,1..3] of ShortInt;
  38.   BlockArray    = Array [0..BlockMaxY-1, 0..BlockMaxX-1] of Byte;
  39.   VGAType      = Array[0..199, 0..319] of Byte;
  40.   SxhmataTyp   = Array[0..NumSxhma-1] OF PointArray;
  41.   MArrTyp      = PointArray;
  42.   TxtBMap      = Array[0..7,0..2048] OF byte;
  43.  
  44.  
  45.  
  46. var
  47.   Fseg,Fofs : word;
  48.   VGA       : VGAPtr;
  49.   Block      : ^BlockArray;
  50.   BlockPal   : ^PaletteType;
  51.   SinTab    : ^TabType;
  52.   Sxhmata   : ^SxhmataTyp;
  53.   MArr      : ^MarrTyp;
  54.   PA1       : ^PointArray;
  55.   TxtBit    : TxtBMap;
  56.   Cover     : Array[0..320*8] of byte;
  57.   I         : Byte;
  58.  
  59. Procedure SetPal(Start: byte; Anz: word; pal: pointer); assembler;
  60. asm
  61.   push ds
  62.   cld
  63.   lds si,pal
  64.   mov dx,3c8h
  65.   mov al,start
  66.   out dx,al
  67.   inc dx
  68.   mov ax,anz
  69.   mov cx,ax
  70.   add cx,ax
  71.   add cx,ax
  72.   rep outsb
  73.   pop ds
  74. end;
  75.  
  76.  
  77. Procedure GetPal(Start: byte; Anz: word; pal: pointer); assembler;
  78. asm
  79.   les di,pal
  80.   mov al,start
  81.   mov dx,3c7h
  82.   out dx,al
  83.   inc dx
  84.   mov ax,anz
  85.   mov cx,ax
  86.   add cx,ax
  87.   add cx,ax
  88.   mov dx,3c9h
  89.   cld
  90.   rep insb
  91. end;
  92.  
  93.  
  94. procedure GetFont; assembler; asm
  95.   mov ax,1130h; mov bh,1; int 10h; mov Fseg,es; mov Fofs,bp; end;
  96.  
  97. procedure SetGraphics(Mode : word); assembler;
  98. asm mov ax,Mode; int 10h; end;
  99.  
  100. procedure Calcsinus(var SinTab : TabType); var I : byte; begin
  101.   for I := 0 to 255 do SinTab[I] := round(sin(2*I*pi/255)*255); end;
  102.  
  103. function Sinus(Idx : byte) : integer; begin
  104.   Sinus := SinTab^[Idx]; end;
  105.  
  106. function Cosinus(Idx : byte) : integer; begin
  107.   Cosinus := SinTab^[(Idx+192) mod 255]; end;
  108.  
  109. function keypressed : boolean; assembler;
  110. asm mov ah,0bh; int 21h; and al,0feh; end;
  111.  
  112. Procedure DefineBlock;
  113. Var CounterX,
  114.     CounterY  : Word;
  115. Begin
  116.      For CounterY := 0 to BlockMaxY-1 do
  117.          For CounterX := 0 to BlockMaxX-1 do
  118.              Block^[CounterY,CounterX]:=1+CounterX+(CounterY*BlockMaxX);
  119. End;
  120.  
  121. Procedure DefinePalette;
  122. Var PalX : Byte;
  123.     PalY : Byte;
  124.     PalSize     : Byte;
  125.     I           : Word;
  126. Const
  127.    Imag : Array [0..BlockMaxY-1,0..BlockMaxX-1] OF Byte=
  128.    ((0,0,0,0,0,0,7,7,7,7,0,0,0,0,0),
  129.     (0,0,0,0,7,6,5,5,5,5,6,7,0,0,0),
  130.     (0,0,0,7,5,4,4,3,3,3,3,5,7,0,0),
  131.     (0,0,7,5,4,4,3,3,2,2,3,3,6,0,0),
  132.     (0,0,6,5,4,4,3,2,1,1,2,3,4,7,0),
  133.     (0,7,5,5,4,4,3,3,2,2,3,3,4,6,0),
  134.     (0,7,5,5,4,4,4,3,3,3,3,4,4,6,0),
  135.     (0,7,5,5,4,4,4,4,4,4,4,4,4,7,0),
  136.     (0,0,6,5,5,4,4,4,4,4,4,4,5,7,0),
  137.     (0,0,7,5,5,5,5,4,4,4,4,5,7,0,0),
  138.     (0,0,0,7,5,5,5,5,5,5,5,7,0,0,0),
  139.     (0,0,0,0,7,6,5,5,5,6,7,0,0,0,0),
  140.     (0,0,0,0,0,0,0,0,0,0,0,0,0,0,0),
  141.     (0,0,0,0,0,0,0,0,0,0,0,0,0,0,0));
  142.  
  143. Begin
  144.      PalSize := (BlockMaxX * BlockMaxY);
  145.      For PalY:=0 to BlockMaxY-1 Do
  146.        For PalX:=0 To BlockMaxX-1 Do
  147.          With Blockpal^[(PalY*BlockMaxX)+PalX+1] do
  148.          Case Imag[Paly,Palx] OF
  149.            0 : Begin R:= 0; G := 0; B:= 0;  end;
  150.            1 : Begin R:= 5; G := 5; B:= 28; End;
  151.            2 : Begin R:= 1; G := 1; B:= 25; End;
  152.            3 : Begin R:= 1; G := 1; B:= 22; End;
  153.            4 : Begin R:= 1; G := 1; B:= 19; End;
  154.            5 : Begin R:= 1; G := 1; B:= 16; End;
  155.            6 : Begin R:= 1; G := 1; B:= 13; End;
  156.            7 : Begin R:= 1; G := 1; B:= 10; End;
  157.          end;
  158.     for I := 1 to 30 do
  159.       With Blockpal^[I+210] do
  160.       begin
  161.         R:=64-Round((I-1)*1.8); G:=64-Round((i-1)*1.6); B:=0;
  162.       end;
  163.     for I := 1 to 8 do
  164.       With Blockpal^[I+240] do
  165.       begin
  166.         R:=63-(I-1)*7; G:=53-(I-1)*7 ; B:=63-(I-1)*7;
  167.       end;
  168. End;
  169.  
  170. Procedure DrawScreen;
  171. var x,y,zz :Integer;
  172. begin
  173.   For x:=0 to 319 do
  174.     for y:=0 to 199 do
  175.       IF Y<150 then
  176.         VGA^[Y,X] :=Block^[Y MOD BlockMaxY, X  MOD BlockMaxX]
  177.       else
  178.         VGA^[Y,X] :=Block^[(215-y) MOD BlockMaxY, (((X-160)*50
  179.           DIV (y-100))+340+(Cosinus(y*20) div 150))  MOD BlockMaxX]
  180. end;
  181.  
  182. {------ Routines for the "Moving Backround" -------}
  183.  
  184. Procedure ShiftBackDown;
  185. Type  TempPalType = Array[1..BlockMaxX] of PaletteRec;
  186. Var   TempPal     : TempPalType;
  187.       CounterX,
  188.       CounterY    : Word;
  189. Begin
  190.      For CounterX := 1 to BlockMaxX do
  191.          TempPal[CounterX] := Blockpal^[CounterX];
  192.      For CounterY := 0 to (BlockMaxY-1) do
  193.          For CounterX := 0 to (BlockMaxX-1) do
  194.              Blockpal^[1 + CounterX + (CounterY * BlockMaxX)] :=
  195.                     Blockpal^[1 + CounterX + ((CounterY+1) * BlockMaxX)];
  196.      For CounterX := 1 to BlockMaxX do
  197.          Blockpal^[CounterX + ((BlockMaxY-1) * BlockMaxX)] :=
  198.                 TempPal[CounterX];
  199. End;
  200.  
  201. Procedure ShiftBackRight;
  202. Type TempPalType = Array[0..BlockMaxY-1] of PaletteRec;
  203. Var  TempPal   : TempPalType;
  204.      CounterX,
  205.      CounterY  : Byte;
  206. Begin
  207.      For CounterY := 0 to BlockMaxY-1 do
  208.          TempPal[CounterY] := Blockpal^[1 + CounterY * BlockMaxX];
  209.      For CounterX := 0 to BlockMaxX-1 do
  210.          For CounterY := 0 to BlockMaxY-1 do
  211.              Blockpal^[1 + (CounterY * BlockMaxX) + CounterX] :=
  212.                     Blockpal^[1 + (CounterY * BlockMaxX) + CounterX + 1];
  213.      For CounterY := 0 to BlockMaxY-1 do
  214.          Blockpal^[(CounterY * BlockMaxX) + BlockMaxX] := TempPal[CounterY];
  215. End;
  216.  
  217. Procedure ShiftBackLeft;
  218. Type TempPalType = Array[0..BlockMaxY-1] of PaletteRec;
  219. Var  TempPal   : TempPalType;
  220.      CounterX,
  221.      CounterY  : Word;
  222. Begin
  223.      For CounterY := 0 to BlockMaxY-1 do
  224.          TempPal[CounterY] := Blockpal^[(CounterY * BlockMaxX) + BlockMaxX];
  225.      For CounterX := BlockMaxX-2 downto 0 do
  226.          For CounterY := 0 to BlockMaxY-1 do
  227.              Blockpal^[2 + (CounterY * BlockMaxX) + CounterX] :=
  228.                     Blockpal^[1 + (CounterY * BlockMaxX) + CounterX];
  229.      For CounterY := 0 to BlockMaxY-1 do
  230.          Blockpal^[1 + (CounterY * BlockMaxX)] := TempPal[CounterY];
  231. End;
  232. {--------------------------------------------------}
  233.  
  234. Procedure CalcMorph(F,T,P : Byte);
  235. Var pnt,l,m : Byte;
  236.     xd      : shortInt;
  237. begin
  238.   For pnt:=1 to NumPnts do
  239.     For l:=1 to 3 do
  240.     begin
  241.       xd:=(Sxhmata^[T][pnt,l]-Sxhmata^[f][pnt,l]);
  242.       MArr^[pnt,l]:=Sxhmata^[f][pnt,l]+((xd*p) DIV MorphSize);
  243.     end;
  244. end;
  245.  
  246. Procedure DoMorph;
  247. Type
  248.   ShadePtsT    = Array[1..NumPnts,0..2] OF Word;
  249. Var
  250.   Shp       : ShadePtsT;
  251.   Frst,
  252.   OutOfX,
  253.   OutOfY    : Boolean;
  254.   sxhma,
  255.   NSxhma,
  256.   MPHase,
  257.   Choice,DV,
  258.   DTime,
  259.   tempa     : byte;
  260.   Inv,iny,
  261.   inz       : Shortint;   { Xstep , Ystep for Moving }
  262.   I,
  263.   X,Y,Z,
  264.   X1,Y1,
  265.   Z1,PhiX,
  266.   PhiY,PhiZ : Integer;
  267.   Count2,
  268.   PalBuf    : Word;
  269.  
  270. begin
  271.   Pa1:=@Sxhmata^[0];
  272.   FillChar(Shp,SizeOF(SHp),0);
  273.   FillChar(MArr^,SizeOF(MarrTyp),0);
  274.   Sxhma:=0; PhiX := 0; PhiY := 0; PhiZ := 0;
  275.   Inv:=2; iny:=-2; inz:=1;
  276.   DTime  := 100;
  277.   Choice := 0;
  278.   Frst:=True;
  279.   Count2:=0; MPhase:=0;
  280.   Move(VGA^[170,0],Cover,320*8);
  281.   Repeat
  282.     ShiftBackDown;
  283.     If DTime=0
  284.     Then
  285.     Begin
  286.          Choice := Random(3);
  287.          DTime  := 40 + Random(160);
  288.     End;
  289.     IF Choice=1 Then ShiftBackRight ELSE
  290.       IF Choice=2 Then ShiftBackLeft;
  291.     IF Dist=0 then inz:=2;
  292.     IF Dist=200 then inz:=-2;
  293.     DV:=Dist div 5;
  294.     IF Count2>=150 then
  295.       if (Sox>140) And (Sox<220) Then
  296.         if (Soy>80) And (Soy<120) Then
  297.         begin
  298.           MPhase:=1;
  299.           NSxhma:=Succ(Random(NumSxhma-1))+Sxhma;
  300.           If NSxhma>=NumSxhma Then NSxhma:=NSxhma-NumSxhma;
  301.           count2:=0;
  302.         end;
  303.     IF (MPhase>0) then
  304.       IF Count2=2 Then
  305.         IF (MPhase<MorphSize+1) Then
  306.         begin
  307.           CalcMorph(Sxhma,NSxhma,Mphase);
  308.           Pa1:=@MArr^;
  309.           Inc(MPhase);
  310.           Count2:=0;
  311.         end
  312.         ELSE
  313.         begin
  314.           sxhma:=NSxhma;
  315.           Pa1:=@Sxhmata^[Sxhma];
  316.           Mphase:=0;
  317.         end;
  318.     Asm
  319.       {--------- Rotate The Message ---------}
  320.       mov ax,ds
  321.       mov es,ax
  322.       mov bl,8
  323.       mov ax,OFFSET Txtbit
  324.       mov di,ax
  325.       Mov si,di
  326.       inc si
  327.      @RL1:
  328.       mov al,[ds:di]
  329.       mov cx,2048
  330.       rep movsb
  331.       mov [ds:di],al
  332.       inc di
  333.       inc si
  334.       dec bl
  335.       jnz @RL1
  336.  
  337.     {-------- Wait for V-Retrace ----------}
  338.       mov dx,3dah;
  339.       @lre1: in al,dx; test al,8; jnz @lre1;
  340.       @lre2: in al,dx; test al,8; jz @lre2;
  341.     {-------- Set Block Colors ---------}
  342.       PUSH DS
  343.       MOV CX, BlockMaxX * BlockMaxY * 3
  344.       MOV AX, 1
  345.       LDS SI, Blockpal
  346.       INC SI
  347.       INC SI
  348.       INC SI
  349.       MOV DX, 03C8h
  350.       OUT DX, AL
  351.       INC DX
  352.       REP
  353.          OUTSB
  354.       POP DS
  355.     {-------- Restore cover area ----------}
  356.       mov di,320*170
  357.       Mov es,Vseg
  358.       mov si,OFFSET cover
  359.       Mov cx,160*8
  360.      @repem:
  361.       Lodsw
  362.       stosw
  363.       dec cx
  364.       jnz @repem
  365.     {--------- Draw Message on screen ----------}
  366.       mov di,320*170
  367.       mov bl,8
  368.       mov si,OFFSET Txtbit
  369.       cld
  370.     @l1:
  371.       Mov  cx,320
  372.     @l3:
  373.       lodsb
  374.       cmp al,0
  375.       je @l2
  376.       stosb
  377.       jmp @l4
  378.     @l2: inc di
  379.     @l4:
  380.       dec cx
  381.       jnz @l3
  382.       MOV Ax,256*8-319
  383.       add ax,si
  384.       mov si,ax
  385.       dec bl
  386.       jnz @l1
  387.       Mov OutOfX,0
  388.       Mov OutOfY,0
  389.     end;
  390.     For i:=1 To NumPnts do
  391.     begin
  392.       asm
  393.         Mov al,frst   { IF  (Not frst) AND  (Lo(Shp[i,2])<211) then }
  394.         cmp al,0      { Mem[Vseg:Shp[i,0]+320*Shp[i,1]]:=Lo(Shp[i,2]); }
  395.         ja  @skip
  396.         Mov ax,i
  397.         dec ax
  398.         Shl ax,1
  399.         mov si,ax
  400.         Shl ax,1
  401.         ADD si,ax
  402.         mov ax,Word Ptr Shp[si+2]
  403.         cmp ax, 200
  404.         jae @skip
  405.         mov bx,word ptr Shp[si]
  406.         cmp bx,320
  407.         jae @skip
  408.         shl ax,6
  409.         mov di,ax
  410.         shl ax,2
  411.         add di,ax
  412.         add di,bx
  413.         mov ax,Word Ptr Shp[si+4]
  414.         cmp al,211
  415.         jae @skip
  416.         mov [es:di],al
  417.        @Skip:
  418.       end;
  419.       X1 :=(Cosinus(PhiY)*Pa1^[I,1]-Sinus(PhiY)*Pa1^[I,3]) div 255;
  420.       Y1 :=(Cosinus(PhiZ)*Pa1^[I,2]-Sinus(PhiZ)*X1) div 255;
  421.       Z1 :=(Cosinus(PhiY)*Pa1^[I,3]+Sinus(PhiY)*Pa1^[I,1]) div 255;
  422.       X := (Cosinus(PhiZ)*X1+Sinus(PhiZ)*Pa1^[I,2]) div (255+dist);
  423.       Y := (Cosinus(PhiX)*Y1+Sinus(PhiX)*z1) div (255+dist);
  424.       Z := (Cosinus(PhiX)*Z1-Sinus(PhiX)*Y1) div (255+dist);
  425.       Shp[i,0] := Sox+((Xc*Z-X*Zc) div (Z-Zc));
  426.       Shp[i,1] := soy+((Yc*Z-Y*Zc) div (Z-Zc));
  427.       Shp[i,2]:=Mem[Vseg:Shp[i,0]+320*Shp[i,1]];
  428.       IF Shp[i,0]>319 Then OutOfX:=True;
  429.       IF Shp[i,1]>200-DV then OutOfY:=True;
  430.       asm    {  Mem[Vseg:Shp[i,0]+320*Shp[i,1]]:= 240-((Z+40) DIV 3); }
  431.         Mov ax,i
  432.         dec ax
  433.         Shl ax,1
  434.         mov si,ax
  435.         Shl ax,1
  436.         ADD si,ax
  437.         mov ax,Word Ptr Shp[si+2]
  438.         cmp ax, 200
  439.         jae @skip
  440.         mov bx,word ptr Shp[si]
  441.         cmp bx,320
  442.         jae @skip
  443.         shl ax,6
  444.         mov di,ax
  445.         shl ax,2
  446.         add di,ax
  447.         add di,bx
  448.         Mov al,[es:di]
  449.         cmp al,211
  450.         jae @skip
  451.         Mov ax,z
  452.         add ax,40
  453.         mov bl,3
  454.         Div bl
  455.         mov bl,240
  456.         sub bl,al
  457.         mov al,bl
  458.         mov [es:di],al
  459.        @skip:
  460.       end;
  461.     end;
  462.     IF OutOfY Then IF SoY>100 Then INY:=-2 ELSE INY:=2;
  463.     IF OutOfX Then IF SoX>160 Then INv:=-2 ELSE INv:=2;
  464.     asm
  465.       mov frst,0
  466.       INC Phix; INC Phix; Inc Phiy; INC Phiz;
  467.       Inc Count2; Dec DTime;
  468.     end;
  469.     Inc(Sox,inv);
  470.     Inc(Soy,iny);
  471.     Inc(Dist,Inz);
  472.   Until Keypressed;
  473. end;
  474.  
  475. Procedure MakeTxtBit;
  476. var
  477.   i,l,x,CH : BYTE;
  478. begin
  479.   Fillchar(TxtBit,SizeOF(TxtBit),0);
  480.   For i:=0 to Length(scrtext)-1 Do
  481.   begin
  482.     Ch := ord(ScrText[I+1]);
  483.     For L:=0 to 7 do
  484.      for x:=0 to 7 do
  485.        IF ((Mem[Fseg:Fofs+8*ch+l] Shl X) AND 128)<>0 then
  486.            TxtBit[l,(i*8)+x]:=241+(L);
  487.   end;
  488. end;
  489.  
  490. Procedure SxhmataProc; External;
  491. {$L Sxhmata.obj}
  492.  
  493. begin
  494.   New(Sintab);
  495.   New(Marr);
  496.   New(BlockPal);
  497.   New(Block);
  498.   CalcSinus(Sintab^);
  499.   Getfont;
  500.   MakeTxtBit;
  501.   Sxhmata:=@SxhmataProc;
  502.   Randomize;
  503.   VGA := Ptr($A000,$0000);
  504.   SetGraphics($13);
  505.   DefineBlock;
  506.   Fillchar(BlockPal^,SizeOF(BlockPal^),0);
  507.   SetPal(0,255,BlockPal);
  508.   DrawScreen;
  509.   DefinePalette;
  510.   SetPal(0,255,BlockPal);
  511.   DoMorph;
  512. {  Dispose(Block);Dispose(BlockPal);Dispose(Marr);Dispose(SinTab); }
  513. {  Not Needed since TP disposes all of theese by itself on exit    }
  514.   SetGraphics(3);
  515.   For i:=1 to 7 Do WriteLN(FinText[i]);
  516.   asm
  517.     int 16h
  518.     cmp al,0
  519.     jz @fin
  520.     int 16h
  521.    @fin:
  522.   end;
  523. end.
  524.